home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3int.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  8.9 KB  |  408 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3int.c,v 1.4 85/08/22 16:58:27 timo Exp $
  5. */
  6.  
  7. /* B interpreter using theaded trees */
  8.  
  9. #include "b.h"
  10. #include "b0fea.h"
  11. #include "b1mem.h"
  12. #include "b1obj.h"
  13. #include "b2nod.h"
  14. #include "b3err.h"
  15. #include "b3sem.h"
  16. #include "b3env.h"
  17. #include "b3int.h"
  18. #include "b3in2.h"
  19. #include "b3sta.h"
  20.  
  21.  
  22. /* Relicts from old system: */
  23.  
  24. Visible value resval;
  25. Visible bool terminated;
  26.  
  27.  
  28. /* Shorthands: */
  29.  
  30. #define Pop2(fun) (w = pop(), v = pop(), fun(v, w), release(v), release(w))
  31. #define Pop1(fun) (v = pop(), fun(v), release(v))
  32. #define Dyop(funvw) \
  33.     (w = pop(), v = pop(), push(funvw), release(v), release(w))
  34. #define Monop(funv) (v = pop(), push(funv), release(v))
  35. #define Flagged() (Thread2(pc) != NilTree)
  36. #define LocFlagged() (Thread2(pc) != NilTree && !noloc)
  37. #define ValOrLoc(feval, floc) (LocFlagged() ? (floc) : (feval))
  38. #define Jump() (tracing && tr_jump(), next = Thread2(pc))
  39. #define Comp(op) (w = pop(), v = pop(), report = (compare(v, w) op 0), Comp2())
  40. #define Comp2() (release(v), !Flagged() ? release(w) : Comp3())
  41. #define Comp3() (report ? push(w) : (Jump(), release(w)))
  42. #define F(n) ((value)*Branch(pc, (n)))
  43.  
  44.  
  45. /* Execute a threaded tree until the end or until a terminating-command.
  46.    The boolean argument 'wantvalue' tells whether it must deliver
  47.    a value or not.
  48. */
  49.  
  50. Hidden value
  51. run(start, wantvalue) parsetree start; bool wantvalue; {
  52.     value u, v, w; int k; bool X, Y; int call_stop= call_level;
  53. #ifdef IBMPC
  54.     int loopcnt= 0;
  55. #endif
  56.     parsetree old_next= next;
  57.     /* While run can be used recursively, save some state info */
  58.  
  59.     next= start;
  60.     for (;;) {
  61. #ifdef IBMPC
  62.         if (loopcnt++ == 100) {
  63.             bdos(0x2c, 0, 0);
  64.             /* forcing a DOS function call (get time) */
  65.             /* so that a break interrupt can be executed */
  66.             loopcnt= 0;
  67.         }
  68. #endif
  69.         if (!still_ok) break;
  70.         pc= next;
  71.         if (pc == Halt) {
  72.             error(MESS(3500, "unexpected program halt"));
  73.             break;
  74.         }
  75.         if (!Is_parsetree(pc)) {
  76.             if (pc == Stop) {
  77.                 if (call_level == call_stop) break;
  78.                 ret();
  79.                 continue;
  80.             }
  81.             if (!Is_number(pc)) syserr(MESS(3501, "run: bad thread"));
  82.             switch (intval(pc)) {
  83.             case 0:
  84.                 pc= Stop;
  85.                 break;
  86.             case 1:
  87.                 error(
  88.             MESS(3502, "none of the alternative tests of SELECT succeeds"));
  89.                 break;
  90.             case 2:
  91.                 if (resexp == Rep)
  92.                     error(MESS(3503, "TEST-unit reports no outcome"));
  93.                 else
  94.                     error(MESS(3504, "YIELD-unit returns no value"));
  95.                 break;
  96.             case 3:
  97.                 if (resexp == Rep)
  98.                  error(MESS(3505, "test-refinement reports no outcome"));
  99.                 else
  100.                  error(MESS(3506, "refinement returns no value"));
  101.                  /* "expression-" seems superfluous here */
  102.                 break;
  103.             default:
  104.                 v= convert(pc, No, No);
  105.                 error3(MESS(3507, "run-time error "), v, 0);
  106.                 release(v);
  107.             }
  108.             continue;
  109.         }
  110.         next = Thread(pc);
  111.         if (tracing) tr_node(pc);
  112. /* <<<<<<<<<<<<<<<< */
  113. switch (Nodetype(pc)) {
  114.  
  115. case HOW_TO:
  116. case REFINEMENT:
  117.     error(MESS(3508, "run: cannot execute unit-definition"));
  118.     break;
  119.  
  120. case YIELD:
  121. case TEST:
  122.     switch (Nodetype(F(FPR_FORMALS))) {
  123.     case TAG:
  124.         break;
  125.     case MONF: case MONPRD:
  126.         w= pop(); v= pop();
  127.         put(v, w); release(v); release(w);
  128.         break;
  129.     case DYAF: case DYAPRD:
  130.         w= pop(); v= pop(); u= pop();
  131.         put(u, w); release(u); release(w);
  132.         u= pop();
  133.         put(u, v); release(u); release(v);
  134.         break;
  135.     default:
  136.         syserr(MESS(3509, "bad FPR_FORMAL"));
  137.     }
  138.     break;
  139.  
  140. /* Commands */
  141.  
  142. case SUITE:
  143.     curlino = F(SUI_LINO);
  144.     curline = F(SUI_CMD);
  145.     break;
  146.  
  147. case IF:
  148. case AND:
  149. case WHILE:
  150. case TEST_SUITE:
  151.     if (!report) Jump(); break;
  152.  
  153. case OR: if (report) Jump(); break;
  154.  
  155. case FOR:
  156.     w= pop(); v= pop();
  157.     if (!in_ranger(v, &w)) { release(v); release(w); Jump(); }
  158.     else { push(v); push(w); }
  159.     break;
  160.  
  161. case PUT: Pop2(put_with_check); break;
  162. case INSERT: Pop2(l_insert); break;
  163. case REMOVE: Pop2(l_remove); break;
  164. case CHOOSE: Pop2(choose); break;
  165. case DRAW: Pop1(draw); break;
  166. case SET_RANDOM: Pop1(set_random); break;
  167. case DELETE: Pop1(l_delete); break;
  168. case CHECK: if (!report) checkerr(); break;
  169.  
  170. case WRITE:
  171.     nl(F(WRT_L_LINES));
  172.     if (F(WRT_EXPR)) { v = pop(); writ(v); release(v); }
  173.     nl(F(WRT_R_LINES));
  174.     break;
  175.  
  176. case READ: Pop2(read_eg); break;
  177.  
  178. case READ_RAW: Pop1(read_raw); break;
  179.  
  180. case QUIT:
  181.     if (resexp != Voi)
  182.        error(MESS(3510, "QUIT may only occur in a HOW'TO or command-refinement"));
  183.     if (call_level == 0 && still_ok) terminated= Yes;
  184.     next= Stop; break;
  185. case RETURN:
  186.     if (resexp != Ret)
  187.        error(MESS(3511, "RETURN may only occur in a YIELD or expression-refinement"));
  188.     resval = pop(); next= Stop; break;
  189. case REPORT:
  190.     if (resexp != Rep)
  191.        error(MESS(3512, "REPORT may only occur in a TEST-unit or test-refinement"));
  192.     next= Stop; break;
  193. case SUCCEED:
  194.     if (resexp != Rep)
  195.        error(MESS(3513, "SUCCEED may only occur in a TEST-unit or test-refinement"));
  196.     report = Yes; next= Stop; break;
  197. case FAIL:
  198.     if (resexp != Rep)
  199.        error(MESS(3514, "FAIL may only occur in a TEST-unit or test-refinement"));
  200.     report = No; next= Stop; break;
  201.  
  202. case USER_COMMAND:
  203.     x_user_command(F(UCMD_NAME), F(UCMD_ACTUALS), F(UCMD_DEF));
  204.     break;
  205.  
  206. case EXTENDED_COMMAND:
  207. #ifdef EXT_COMMAND
  208.     x_extended_command(F(ECMD_NAME), F(ECMD_ACTUALS));
  209. #endif
  210.     break;
  211.  
  212. /* Expressions, targets */
  213.  
  214. case COLLATERAL:
  215.     v = mk_compound(k= Nfields(F(COLL_SEQ)));
  216.     while (--k >= 0)
  217.         *Field(v, k) = pop();
  218.     push(v);
  219.     break;
  220.  
  221. /* Expressions, targets */
  222.  
  223. case SELECTION: Dyop(ValOrLoc(associate(v, w), tbsel_loc(v, w))); break;
  224.  
  225. case BEHEAD:
  226.     w= pop(); v= pop();
  227.     push(LocFlagged() ? trim_loc(v, w, '@') : behead(v, w));
  228.     release(v); release(w);
  229.     break;
  230.  
  231. case CURTAIL:
  232.     w= pop(); v= pop();
  233.     push(LocFlagged() ? trim_loc(v, w, '|') : curtail(v, w));
  234.     release(v); release(w);
  235.     break;
  236.  
  237. case MONF:
  238.     v = pop();
  239.     formula(Vnil, F(MON_NAME), v, F(MON_FCT));
  240.     release(v);
  241.     break;
  242.  
  243. case DYAF:
  244.     w = pop(); v = pop();
  245.     formula(v,  F(DYA_NAME), w, F(DYA_FCT));
  246.     release(v); release(w);
  247.     break;
  248.  
  249. case TEXT_LIT:
  250.     v= F(XLIT_TEXT);
  251.     if (F(XLIT_NEXT)) { w= pop(); v= concat(v, w); release(w); }
  252.     else copy(v);
  253.     push(v);
  254.     break;
  255.  
  256. case TEXT_CONV:
  257.     if (F(XCON_NEXT)) w= pop();
  258.     u= pop();
  259.     v= convert(u, Yes, Yes);
  260.     release(u);
  261.     if (F(XCON_NEXT)) {
  262.         v= concat(u= v, w);
  263.         release(u);
  264.         release(w);
  265.     }
  266.     push(v);
  267.     break;
  268.  
  269. case ELT_DIS: push(mk_elt()); break;
  270.  
  271. case LIST_DIS:
  272.     u = mk_elt();
  273.     k= Nfields(F(LDIS_SEQ));
  274.     while (--k >= 0) {
  275.         insert(v = pop(), &u);
  276.         release(v);
  277.     }
  278.     push(u);
  279.     break;
  280.  
  281. case RANGE_DIS: Dyop(mk_range(v, w)); break;
  282.  
  283. case TAB_DIS:
  284.     u = mk_elt();
  285.     k= Nfields(F(TDIS_SEQ));
  286.     while ((k -= 2) >= 0) {
  287.         w = pop(); v = pop();
  288.         /* Should check for same key with different associate */
  289.         replace(w, &u, v);
  290.         release(v); release(w);
  291.     }
  292.     push(u);
  293.     break;
  294.  
  295. /* Tests */
  296.  
  297. case NOT: report = !report; break;
  298.  
  299. /* Quantifiers can be described as follows:
  300.    Report X at first test which reports Y.  If no test reports Y, report !X.
  301.       type    X    Y
  302.       SOME    Yes    Yes
  303.       EACH    No    No
  304.       NO    No    Yes. */
  305.  
  306. case EACH_IN:    X= Y= No; goto quant;
  307. case NO_IN:    X= No; Y= Yes; goto quant;
  308. case SOME_IN:    X= Y= Yes;
  309. quant:
  310.     w= pop(); v= pop();
  311.     if (Is_compound(w) && report == Y) { report= X; Jump(); }
  312.     else if (!in_ranger(v, &w)) { report= !X; Jump(); }
  313.     else { push(v); push(w); break; }
  314.     release(v); release(w);
  315.     break;
  316.  
  317. case EACH_PARSING:    X= Y= No; goto parse;
  318. case NO_PARSING:    X= No; Y= Yes; goto parse;
  319. case SOME_PARSING:    X= Y= Yes;
  320. parse:
  321.     w= pop(); v= pop();
  322.     if (Is_compound(w) && report == Y) { report= X; Jump(); }
  323.     else if (!pa_ranger(v, &w)) { report= !X; Jump(); }
  324.     else { push(v); push(w); break; }
  325.     release(v); release(w);
  326.     break;
  327.  
  328. case MONPRD:
  329.     v = pop();
  330.     proposition(Vnil, F(MON_NAME), v, F(MON_FCT));
  331.     release(v);
  332.     break;
  333.  
  334. case DYAPRD:
  335.     w = pop(); v = pop();
  336.     proposition(v, F(DYA_NAME), w, F(DYA_FCT));
  337.     release(v); release(w);
  338.     break;
  339.  
  340. case LESS_THAN: Comp(<); break;
  341. case AT_MOST: Comp(<=); break;
  342. case GREATER_THAN: Comp(>); break;
  343. case AT_LEAST: Comp(>=); break;
  344. case EQUAL: Comp(==); break;
  345. case UNEQUAL: Comp(!=); break;
  346.  
  347. case TAGformal:
  348.     call_formal(F(TAG_NAME), F(TAG_ID), LocFlagged());
  349.     break;
  350.  
  351. case TAGlocal:
  352.     push(ValOrLoc(v_local(F(TAG_NAME), F(TAG_ID)), local_loc(F(TAG_ID))));
  353.     break;
  354.  
  355. case TAGglobal:
  356.     push(ValOrLoc(v_global(F(TAG_NAME)), global_loc(F(TAG_NAME))));
  357.     break;
  358.  
  359. case TAGmystery:
  360.     if (LocFlagged()) push(l_mystery(F(TAG_NAME), F(TAG_ID)));
  361.     else v_mystery(F(TAG_NAME), F(TAG_ID));
  362.     break;
  363.  
  364. case TAGrefinement:
  365.     call_refinement(F(TAG_NAME), F(TAG_ID), Flagged());
  366.     break;
  367.  
  368. case TAGzerfun:
  369.     formula(Vnil,  F(TAG_NAME), Vnil, F(TAG_ID));
  370.     break;
  371.  
  372. case TAGzerprd:
  373.     proposition(Vnil,  F(TAG_NAME), Vnil, F(TAG_ID));
  374.     break;
  375.  
  376. case NUMBER:
  377.     push(copy(F(NUM_VALUE)));
  378.     break;
  379.  
  380. default:
  381.     syserr(MESS(3515, "run: bad node type"));
  382.  
  383. }
  384. /* >>>>>>>>>>>>>>>> */
  385.     }
  386.     v = Vnil;
  387.     if (wantvalue && still_ok) v = pop();
  388.     /* Unwind stack when stopped by error: */
  389.     while (call_level != call_stop) ret();
  390.     next= old_next;
  391.     return v;
  392. }
  393.  
  394.  
  395. /* External interfaces: */
  396.  
  397. Visible Procedure execthread(start) parsetree start; {
  398.     run(start, No);
  399. }
  400.  
  401. Visible value evalthread(start) parsetree start; {
  402.     return run(start, Yes);
  403. }
  404.  
  405. Visible Procedure initint() {
  406.     /* Dummy, relict */
  407. }
  408.